(STATUS 2 1 2)


(MAPC '(I J K L M N P Q R S U V W X Y Z) 'SET)




(SETQ OKS T)
(SETQ OKP T)


(DE UNREC () (SETQ PC (RESTORE)))

(DE SAVE (1X) (SETQ STACK (CONS 1X STACK))
  (IF (< (LENGTH STACK) 500) NIL
       (PRINT 'ERR-FS) (LANCER))
 (IF OKS (PRINT 'LENGTH-STACK '= (LENGTH STACK))))
(DE RESTORE () (NEXTL STACK))


(DF DFP (1X) (SETQ 1Y (CONS LAMBDA (CDR 1X)))

  (PUT (CAR 1X) 1Y 'FPROG)
  (PUT (CAR 1X) 1Y 'EXPR))

(DFP DINT () (SETQ A1 (PUT (CAR A1)
              (CONS LAMBDA (CDR A1)) 'INT)) (UNREC))
(DFP DFINT () (SETQ A1 (PUT (CAR A1)
               (CONS LAMBDA (CDR A1)) 'FINT)) (UNREC))


; (DFP ... POUR LES "FSUBRS"
 (DINT ... POUR LES "EXPRS"
 (DFINT... POUR LES "FEXPRS"  ;

 ; NOTER QUE
      INT=EXPR
      FINT=FEXPR
      FPROG=FSUBR  ;

(DE LANCER () (SETQ PC 'TOP) (MLOOP))

(DE MLOOP () (WHILE T (IF OKP (PRINT '=> PC))
                      (APPLY PC NIL)))
(DE TOP ()
  (SETQ LLINK NIL STACK NIL) (SAVE 'TOP2)
  (PRINT 'TOP-LEVEL)
  (SETQ A1 (READ) PC 'AEVAL))
(DE TOP2 () (PRINT A1) (SETQ PC 'TOP))

(DE LIER2 ()
  (WHILE (LISTP RX) (SET (NEXTL RX) (NEXTL RY)))
  (IF (NULL RX) NIL (SET RX RY)))

(DE LIER ()
  (SAVE LLINK) (SAVE -1)
  (WHILE (LISTP RX)
    (SAVE (CAAR RX)) (SAVE (CAR RX)) (SET (NEXTL RX) (NEXTL RY)))
  (IF (NULL RX) NIL
      (SAVE (CAR RX)) (SAVE RX) (SET RX RY))
  (SETQ LLINK STACK))

(DE DELIER ()

  (SETQ STACK LLINK)
  (WHILE (NEQ -1 (CAR STACK)) (SET (RESTORE) (RESTORE)))
  (RESTORE) ; LE "-1";

  (SETQ LLINK (RESTORE)))

(DE AEVAL () ; ARG DS A1 ;
  (COND
    ((ATOM A1) (IF (NUMBP A1) NIL (SETQ A1 (CAR A1))) (UNREC))
    ((= (CAR A1) QUOTE) (SETQ A1 (CADR A1)) (UNREC))
    (T (SETQ F (CAR A1) A1 (CDR A1) PC 'EVAL1)) ))


(DE EVAL1 () ; ARGS DS F ET A1;

  (COND
    ((LISTP F) (SAVE F) (SETQ PC 'AEVLIS))
      ;CAS F ATOME ;

    ((OR (SETQ 1X (GET F 'INT)) (= (TYPEFN F) SUBR))
     (SAVE F) (SETQ PC 'AEVLIS))
    ((SETQ 1X (GET F 'FINT))
     (SETQ A4 [A1] A1 1X PC 'EAPPLY))
    ((GET F 'FPROG) (SETQ PC F))
    (T (SETQ F (CAR F))) ))

(DE AEVLIS () ; ARG A EVALUER DS A1, RES CONSTRUIT DS A2 ;
      (SETQ A2 NIL PC 'EVLIS1))
(DE EVLIS1 () (COND
    (A1 (SAVE A1) (SAVE A2) (SAVE 'EVLIS2)
        (SETQ A1 (CAR A1) PC 'AEVAL))
    (T (SETQ A4 (REVERSE A2) A1 (RESTORE) PC 'EAPPLY)) ))
(DE EVLIS2 ()
  (SETQ A2 (RESTORE) A2 (CONS A1 A2) A1 (RESTORE)
        A1 (CDR A1) PC 'EVLIS1))

(DE EAPPLY () ; FONC DS A1, LARG DS A4 ;
  (COND
    ((NUMBP A1) (SETQ A1 (CNTH A1 (CAR A4))) (UNREC))
    ((ATOM A1) (COND
      ((OR (SETQ 1X (GET A1 'INT)) (SETQ 1X (GET A1 'FINT)))
       (SETQ A1 1X))
      ((= (TYPEFN A1) SUBR)






       (SETQ A1 (APPLY A1 A4)) (UNREC))
       ;I.E. (SETQ F A1 A1 (CAR A4) A2 (CADR A4) A3 (CADDR A4) PC F) ;
      ((GET A1 'FPROG) (SETQ F A1 A1 A4 PC F))
      (T (SETQ A1 (CAR A1))) ))
    ((OR (= (CAR A1) (SETQ 1X LAMBDA)) (=(CAR A1)(SETQ 1X 'GAMMA)))
     (IF (= 1X 'GAMMA) (SETQ A4 (CAR A4)))
     (SETQ RX (CADR A1) RY A4 A1 (CDDR A1))
     (COND ((= (CADR STACK) A1)
            (LIER2) (SETQ PC 'APROGN))

           (T (LIER) (SAVE A1) (SAVE 'APPLY3) (SETQ PC 'APROGN))))
    (T (SAVE A4) (SAVE 'APPLY2) (SETQ PC 'AEVAL)) ))

(DE APPLY2 () (SETQ A4 (RESTORE) PC 'EAPPLY))


(DE APPLY3 () (DELIER) (UNREC))

(DE APROGN () (COND
  ((CDR A1) (SAVE A1) (SAVE 'PROGN2) (SETQ A1 (CAR A1) PC 'AEVAL))
  (T (SETQ A1 (CAR A1) PC 'AEVAL)) ))
(DE PROGN2 ()
  (SETQ A1 (RESTORE) A1 (CDR A1) PC 'APROGN))



 ; WARNING : USE "IFF" INSTEAD OF "IF"
 FOR THE "DFP" BINDS FUNCTION NAMES WITH EXPR ON P-LISTS ;

 ; ET LE IF SYSTEME SE TROUVERAIT AINSI REDEFINI COMME 
  UNE EXPR ET CE SERAIT HORRIBLE ! ;

(DFP IFF () ; ARG DS A1 ;
  (SAVE A1) (SAVE 'IF2) (SETQ A1 (CAR A1) PC 'AEVAL))
(DE IF2 ()
  (SETQ A2 (RESTORE))
  (IF A1 (SETQ A1 (CADR A2) PC 'AEVAL)
         (SETQ A1 (CDDR A2) PC 'APROGN)))






(PROGN (STATUS 1 1 2)
 '(INTERL LOADED - WARNING USE IFF FOR IF))